'[declare]
'PlaySound
Public Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
'sleep
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'[attribute]
'文档自定义属性
ThisWorkbook.CustomDocumentProperties("属性名")
'[code_snippet]
'代码发送按键
Set x = CreateObject("Wscript.shell")
x.SendKeys ("%{down}")
'创建剪贴板
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '创建剪切板对象
            .SetText [要写入剪贴板的内容]                            '设置将存入剪贴板的数据
            .PutInClipboard                               '将数据存入剪贴板
End With
'[function]
'单元格批注修改历史记录
Public Function AddCommentForCell(Target As Range)
    If Target.Count > 1 Then Target = Target.Cells(1)
    If Target.Comment Is Nothing Then Target.AddComment
    With Target.Comment
            .Text Text:=CStr(.Text & Chr(10) & Now & Chr(32) & Target.Value)
    End With
    With Target.Comment.Shape
        .TextFrame.AutoSize = True
        If .Width > 300 Then .Width = 300
        If .Height < 63 Then .Height = 63
    End With
    Target.Comment.Visible = False
    AddCommentForCell = Target
End Function
'工作簿终结者
public sub workbookTerminator()
    With ThisWorkbook
            .Saved = True
            .ChangeFileAccess xlReadOnly
            Kill .FullName
            .Close False
    End With
End Sub
'错误转换真假值
Public Function ErrorToBoolean(para As Variant)
    If TypeName(para) = "Error" Then
        ErrorToBoolean = False
    Else
        ErrorToBoolean = True
    End If
End Function
'任意对象转换为真假值
Public Function ToCondition(everything As Variant)
    Dim paraType As String
    paraType = TypeName(everything)
    If paraType = "Empty" _
        Or paraType = "Integer" _
        Or paraType = "Double" _
        Or paraType = "Null" Then
        ToCondition = everything
    ElseIf paraType = "Range" Then
        ToCondition = True
    ElseIf paraType = "String" Then
        If everything = 0 Or Len(everything) = 0 Then
            ToCondition = False
        ElseIf Len(everything) > 0 Then
            ToCondition = True
        End If
    End If
End Function
'创建新工作表
Public Function createSheet(ByVal sheetName As String)
    Dim i As Worksheet
    For Each i In Worksheets
        If i.Name = sheetName Then
            Exit For
        Else
            Set i = Nothing
        End If
    Next i
    If i Is Nothing Then
        Sheets.Add.Name = sheetName
    End If
    Set createSheet = Worksheets(sheetName)
End Function
'文本剪贴板
Sub 文本剪贴板()
    Dim StrValue As String, SourceArr
    On Error Resume Next
    SourceArr = Selection.Value                           '读入选择区域的内容,可根据实际需要选取区域
    For i = 1 To UBound(SourceArr)
        For j = 1 To UBound(SourceArr, 2)
            StrValue = StrValue & vbTab & SourceArr(i, j) '逐行读取数据,合并成字符串,列之间用制表符分隔
        Next
        StrValue = StrValue & vbNewLine                    '每行间连接换行符
    Next
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '创建剪切板对象
            .SetText StrValue                            '设置将存入剪贴板的数据
            .PutInClipboard                              '将数据存入剪贴板
    End With
End Sub
'用outlook发送邮件
'example: SendMail "1297368547@qq.com", "", "测试", "这是一个使用Outlook自动发送的测试邮件。"
Public Sub SendMail( _
    ByVal strTo As String, _
    ByVal strCC As String, _
    ByVal strSubject As String, _
    ByVal strBody As String, _
    Optional ByVal strAttach As String)
    Dim objOutLook As Object
    Dim objMailItem As Object
    Set objOutLook = CreateObject("Outlook.Application")
    Set objMailItem = objOutLook.CreateItem(0)
    With objMailItem
        .To = strTo
        .CC = strCC
        .Importance = 2
        .Subject = strSubject
        .Body = strBody
        If Len(strAttach) <> 0 Then .Attachments.Add strAttach
        .Send
    End With
errHandle:
    Sleep 5000
    objOutLook.Quit
    Set objOutLook = Nothing
    Set objMailItem = Nothing
End Sub
'发送web请求
Sub sendWebRequest(ByVal url As String)
    Dim XMLHTTP As Object
    Dim DOM As Object
    Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
    Set DOM = CreateObject("htmlfile")
    With XMLHTTP
        .Open "get", url, False
        .setRequestHeader "If-Modified-Since", "0"
        .send
    End With
    DOM.body.innerHTML = XMLHTTP.responseText
End Sub
'制作工资条
Public Function createSheet(ByVal sheetName As String)
    Dim i As Worksheet
    For Each i In Worksheets
        If i.Name = sheetName Then
            Exit For
        Else
            Set i = Nothing
        End If
    Next i
    If i Is Nothing Then
        Sheets.Add.Name = sheetName
    End If
    Set createSheet = Worksheets(sheetName)
End Function
Sub 制作工资条(ByVal dataRng As Range)
    Application.ScreenUpdating = False
    Dim tabHeadRng As Range
    Set tabHeadRng = dataRng.Rows(1)
    Dim i As Integer
    With createSheet(dataRng.Parent.Name & " " & "工资条")
        For i = 2 To dataRng.Rows.Count Step 1
            tabHeadRng.Copy .Cells(2 * i - 3, "A")
            dataRng.Rows(i).Copy .Cells(2 * i - 2, "A")
        Next i
    End With
    Application.ScreenUpdating = True
End Sub
'读取txt文件内容（简单）
'文本内容必须连贯
Public Function readyTxt(ByVal pathname As String)
    Dim fileIndex As Integer
    Dim txtContent As String
    fileIndex = FreeFile
    Open pathname For Input As #fileIndex
    Input #fileIndex, txtContent
    readyTxt = txtContent
End Function

'破解xls文件工程密码，如何是xlsm，先将xlsm保存为xls再执行.执行函数的可能要是xls文件
Sub VBAPassword1() '你要解保护的Excel文件路径
    Filename = Application.GetOpenFilename("Excel文件（*.xls & *.xla & *.xlt）,*.xls;*.xla;*.xlt", , "VBA破解")
    If Dir(Filename) = "" Then
        MsgBox "没找到相关文件,清重新设置。"
        Exit Sub
    Else
        FileCopy Filename, Filename & ".bak" '备份文件。
    End If
    Dim GetData As String * 5
    Open Filename For Binary As #1
    Dim CMGs As Long
    Dim DPBo As Long
    For i = 1 To LOF(1)
        Get #1, i, GetData
        If GetData = "CMG=""" Then CMGs = i
        If GetData = "[Host" Then DPBo = i - 2: Exit For
    Next
    If CMGs = 0 Then
        MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
        Exit Sub
    End If
    Dim St As String * 2
    Dim s20 As String * 1
    '取得一个0D0A十六进制字串
    Get #1, CMGs - 2, St
    '取得一个20十六制字串
    Get #1, DPBo + 16, s20
    '替换加密部份机码
    For i = CMGs To DPBo Step 2
        Put #1, i, St
    Next
    '加入不配对符号
    If (DPBo - CMGs) Mod 2 <> 0 Then
        Put #1, DPBo + 1, s20
    End If
    MsgBox "文件解密成功......", 32, "提示"
    Close #1
End Sub
'[easy_snippet]
'[heyuan_work]
'倒序打印所有工作表
Public Sub reverseAllSheetPrint()
 Dim i As Integer
 For i = Sheets.Count To 1 Step -1
    Sheets(i).PrintOut from:=1, To:=1
 Next i
End Sub
'倒序排列所有工作表
Sub reverseAllSheets()
Dim i As Integer
For i = Worksheets.Count - 1 To 1 Step -1
    Debug.Print (i)
   'Debug.Print (Worksheets(i).Name);
   Worksheets(i).Move After:=Worksheets(Worksheets.Count)
Next
End Sub
获取月份最后一天
Sub nb_days_month()
    
    '将日期传入变量，月/日/年
    date_test = CDate("7/13")
    Debug.Print date_test
    '获取日期中的年份和月份
    var_month = Month(date_test)
    var_year = Year(date_test)
    
    '获取下个月的第一天
    date_next_month = DateSerial(var_year, var_month + 1, 1)
    
    '使用下个月的第一天减 1 ，即可得到这个月的最后一天
    last_day_month = date_next_month - 1
    
    '最后一天，即是该月的天数
    nb_days = Day(last_day_month)
    Debug.Print nb_days
End Sub